home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / lsp / arraylib.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  8KB  |  266 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;    arraylib.lsp
  6. ;;;;
  7. ;;;;                            array routines
  8.  
  9.  
  10. (in-package 'lisp)
  11.  
  12.  
  13. (export '(make-array vector
  14.           array-element-type array-rank array-dimension
  15.           array-dimensions
  16.           array-in-bounds-p array-row-major-index
  17.           adjustable-array-p
  18.           bit sbit
  19.           bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor
  20.           bit-andc1 bit-andc2 bit-orc1 bit-orc2 bit-not
  21.           array-has-fill-pointer-p fill-pointer
  22.           vector-push vector-push-extend vector-pop
  23.           adjust-array))
  24.  
  25.  
  26. (in-package 'system)
  27.  
  28.  
  29. (proclaim '(optimize (safety 2) (space 3)))
  30.  
  31.  
  32. (defun make-array (dimensions
  33.            &key (element-type t)
  34.             (initial-element nil initial-element-supplied-p)
  35.             (initial-contents nil initial-contents-supplied-p)
  36.             adjustable fill-pointer
  37.             displaced-to (displaced-index-offset 0)
  38.             static)
  39.   (when (integerp dimensions) (setq dimensions (list dimensions)))
  40.   (cond ((= (length dimensions) 1)
  41.      (let ((x (si:make-vector element-type (car dimensions)
  42.                               adjustable fill-pointer
  43.                               displaced-to displaced-index-offset
  44.                               static)))
  45.        (when initial-element-supplied-p
  46.          (do ((n (car dimensions))
  47.               (i 0 (1+ i)))
  48.              ((>= i n))
  49.            (declare (fixnum n i))
  50.            (si:aset x i initial-element)))
  51.        (when initial-contents-supplied-p
  52.          (do ((n (car dimensions))
  53.               (i 0 (1+ i)))
  54.              ((>= i n))
  55.            (declare (fixnum n i))
  56.            (si:aset x i (elt initial-contents i))))
  57.        x))
  58.         (t
  59.      (let ((x
  60.         (apply #'si:make-pure-array
  61.                element-type adjustable
  62.                displaced-to displaced-index-offset
  63.                static
  64.                dimensions)))
  65.        (when initial-element-supplied-p
  66.          (do ((cursor
  67.                (make-list (length dimensions)
  68.                           :initial-element 0)))
  69.              (nil)
  70.            (aset-by-cursor x initial-element cursor)
  71.            (when (increment-cursor cursor dimensions)
  72.              (return nil))))
  73.        (when initial-contents-supplied-p
  74.          (do ((cursor
  75.                (make-list (length dimensions)
  76.                           :initial-element 0)))
  77.              (nil)
  78.            (aset-by-cursor x
  79.                        (sequence-cursor initial-contents
  80.                                         cursor)
  81.                    cursor)
  82.            (when (increment-cursor cursor dimensions)
  83.                  (return nil))))
  84.        x))))))))))
  85.  
  86.  
  87. (defun increment-cursor (cursor dimensions)
  88.   (if (null cursor)
  89.       t
  90.       (let ((carry (increment-cursor (cdr cursor) (cdr dimensions))))
  91.     (if carry
  92.         (cond ((>= (the fixnum (1+ (the fixnum (car cursor))))
  93.                    (the fixnum (car dimensions)))
  94.            (rplaca cursor 0)
  95.            t)
  96.           (t
  97.            (rplaca cursor
  98.                    (the fixnum (1+ (the fixnum (car cursor)))))
  99.            nil))
  100.         nil))))
  101.  
  102.  
  103. (defun sequence-cursor (sequence cursor)
  104.   (if (null cursor)
  105.       sequence
  106.       (sequence-cursor (elt sequence (the fixnum (car cursor)))
  107.                        (cdr cursor))))
  108.  
  109.  
  110. (defun vector (&rest objects)
  111.   (make-array (list (length objects))
  112.           :element-type t
  113.           :initial-contents objects))
  114.  
  115.  
  116. (defun array-dimensions (array)
  117.   (do ((i (array-rank array))
  118.        (d nil))
  119.       ((= i 0) d)
  120.     (setq i (1- i))
  121.     (setq d (cons (array-dimension array i) d))))
  122.  
  123.  
  124. (defun array-in-bounds-p (array &rest indices &aux (r (array-rank array)))
  125.   (when (/= r (length indices))
  126.         (error "The rank of the array is ~R,~%~
  127.                ~7@Tbut ~R ~:*~[indices are~;index is~:;indices are~] ~
  128.                supplied."
  129.                r (length indices)))
  130.   (do ((i 0 (1+ i))
  131.        (s indices (cdr s)))
  132.       ((>= i r) t)
  133.     (when (or (< (car s) 0)
  134.               (>= (car s) (array-dimension array i)))
  135.           (return nil))))
  136.  
  137.  
  138. (defun array-row-major-index (array &rest indices)
  139.   (do ((i 0 (1+ i))
  140.        (j 0 (+ (* j (array-dimension array i)) (car s)))
  141.        (s indices (cdr s)))
  142.       ((null s) j)))
  143.  
  144.  
  145. (defun bit (bit-array &rest indices)
  146.   (apply #'aref bit-array indices))
  147.  
  148.  
  149. (defun sbit (bit-array &rest indices)
  150.   (apply #'aref bit-array indices))
  151.  
  152.  
  153. (defun bit-and (bit-array1 bit-array2 &optional result-bit-array)
  154.   (bit-array-op boole-and bit-array1 bit-array2 result-bit-array))
  155.  
  156.  
  157. (defun bit-ior (bit-array1 bit-array2 &optional result-bit-array)
  158.   (bit-array-op boole-ior bit-array1 bit-array2 result-bit-array))
  159.  
  160.  
  161. (defun bit-xor (bit-array1 bit-array2 &optional result-bit-array)
  162.   (bit-array-op boole-xor bit-array1 bit-array2 result-bit-array))
  163.  
  164.  
  165. (defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array)
  166.   (bit-array-op boole-eqv bit-array1 bit-array2 result-bit-array))
  167.  
  168.     
  169. (defun bit-nand (bit-array1 bit-array2 &optional result-bit-array)
  170.   (bit-array-op boole-nand bit-array1 bit-array2 result-bit-array))
  171.  
  172.     
  173. (defun bit-nor (bit-array1 bit-array2 &optional result-bit-array)
  174.   (bit-array-op boole-nor bit-array1 bit-array2 result-bit-array))
  175.  
  176.     
  177. (defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array)
  178.   (bit-array-op boole-andc1 bit-array1 bit-array2 result-bit-array))
  179.  
  180.     
  181. (defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array)
  182.   (bit-array-op boole-andc2 bit-array1 bit-array2 result-bit-array))
  183.  
  184.     
  185. (defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array)
  186.   (bit-array-op boole-orc1 bit-array1 bit-array2 result-bit-array))
  187.  
  188.     
  189. (defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array)
  190.   (bit-array-op boole-orc2 bit-array1 bit-array2 result-bit-array))
  191.  
  192.     
  193. (defun bit-not (bit-array &optional result-bit-array)
  194.   (bit-array-op boole-c1 bit-array bit-array result-bit-array))
  195.  
  196.  
  197. (defun vector-push (new-element vector)
  198.   (let ((fp (fill-pointer vector)))
  199.     (declare (fixnum fp))
  200.     (cond ((< fp (the fixnum (array-dimension vector 0)))
  201.            (si:aset vector fp new-element)
  202.            (si:fill-pointer-set vector (the fixnum (1+ fp)))
  203.        fp)
  204.       (t nil))))
  205.  
  206.  
  207. (defun vector-push-extend (new-element vector
  208.                &optional (extension (array-dimension vector 0)))
  209.   (let ((fp (fill-pointer vector)))
  210.     (declare (fixnum fp))
  211.     (cond ((< fp (the fixnum (array-dimension vector 0)))
  212.        (si:aset vector fp new-element)
  213.        (si:fill-pointer-set vector (the fixnum (1+ fp)))
  214.        fp)
  215.       (t
  216.        (adjust-array vector
  217.                      (list (+ (array-dimension vector 0) extension))
  218.                      :element-type (array-element-type vector)
  219.              :fill-pointer fp)
  220.        (si:aset vector fp new-element)
  221.        (si:fill-pointer-set vector (the fixnum (1+ fp)))
  222.        fp))))
  223.  
  224.  
  225. (defun vector-pop (vector)
  226.   (let ((fp (fill-pointer vector)))
  227.     (declare (fixnum fp))
  228.     (when (= fp 0)
  229.           (error "The fill pointer of the vector ~S zero." vector))
  230.     (si:fill-pointer-set vector (the fixnum (1- fp)))
  231.     (aref vector (the fixnum (1- fp)))))
  232.  
  233.  
  234. (defun adjust-array (array new-dimensions
  235.                      &rest r
  236.              &key element-type
  237.               initial-element
  238.               initial-contents
  239.               fill-pointer
  240.               displaced-to
  241.               displaced-index-offset
  242.               static)
  243.   (declare (ignore element-type
  244.                    initial-element
  245.                    initial-contents
  246.                    fill-pointer
  247.                    displaced-to
  248.                    displaced-index-offset
  249.                    static))
  250.   (when (integerp new-dimensions)
  251.         (setq new-dimensions (list new-dimensions)))
  252.   (let ((element-type (array-element-type array)))
  253.     (unless (eq element-type t) (push element-type r)
  254.         (push :element-type r)))
  255.   (let ((x (apply #'make-array new-dimensions :adjustable t r)))
  256.     (do ((cursor (make-list (length new-dimensions) :initial-element 0)))
  257.         (nil)
  258.       (when (apply #'array-in-bounds-p array cursor)
  259.             (aset-by-cursor x
  260.                             (apply #'aref array cursor)
  261.                             cursor))
  262.       (when (increment-cursor cursor new-dimensions)
  263.             (return nil)))
  264.     (si:replace-array array x)
  265.     ))
  266.